Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue37/Alfresco/VSortFns.pas

Pascal/Delphi Source File | 1998-07-27 | 11.8 KB | 353 lines

{*********************************************************}
{* VSortFns                                              *}
{* Copyright (c) Julian M Bucknall 1998                  *}
{* All rights reserved.                                  *}
{*********************************************************}
{* Sort routines for visual display                      *}
{*********************************************************}

{Note: this unit is released as freeware. In other words, you are free
       to use this unit in your own applications, however I retain all
       copyright to the code. JMB}

unit VSortFns;

interface

uses
  StdCtrls,
  SysUtils;

type
  TSortElement = integer;

  TLessFunction = function (X, Y : TSortElement) : boolean;
  TSwapFunction = procedure (var A    : array of integer;
                                 I, J : integer);
  TSetFunction = procedure (var A : array of integer;
                                X : TSortElement;
                                I : integer);

procedure VisualBubbleSort(var A           : array of integer;
                               Left, Right : integer;
                               LessFunc    : TLessFunction;
                               SwapProc    : TSwapFunction);

procedure VisualShakerSort(var A           : array of integer;
                               Left, Right : integer;
                               LessFunc    : TLessFunction;
                               SwapProc    : TSwapFunction);

procedure VisualSelectionSort(var A           : array of integer;
                                  Left, Right : integer;
                                  LessFunc    : TLessFunction;
                                  SwapProc    : TSwapFunction);

procedure VisualInsertionSort(var A           : array of integer;
                                  Left, Right : integer;
                                  LessFunc    : TLessFunction;
                                  SetProc     : TSetFunction);

procedure VisualBestInsertionSort(var A           : array of integer;
                                      Left, Right : integer;
                                      LessFunc    : TLessFunction;
                                      SwapProc    : TSwapFunction;
                                      SetProc     : TSetFunction);

procedure VisualShellsort(var A           : array of integer;
                              Left, Right : integer;
                              LessFunc    : TLessFunction;
                              SwapProc    : TSwapFunction;
                              SetProc     : TSetFunction);

procedure VisualQuicksort(var A           : array of integer;
                              Left, Right : integer;
                              LessFunc    : TLessFunction;
                              SwapProc    : TSwapFunction);

procedure VisualBestQuicksort(var A           : array of integer;
                                  Left, Right : integer;
                                  LessFunc    : TLessFunction;
                                  SwapProc    : TSwapFunction;
                                  SetProc     : TSetFunction);

implementation

procedure VisualBubbleSort(var A           : array of integer;
                               Left, Right : integer;
                               LessFunc    : TLessFunction;
                               SwapProc    : TSwapFunction);
var
  i, j : integer;
begin
  for i := Left to pred(Right) do
    for j := Right downto succ(i) do
      if LessFunc(A[j], A[j-1]) then
        SwapProc(A, j-1, j);
end;

procedure VisualShakerSort(var A           : array of integer;
                               Left, Right : integer;
                               LessFunc    : TLessFunction;
                               SwapProc    : TSwapFunction);
var
  i : integer;
begin
  while (Left < Right) do begin
    for i := Right downto succ(Left) do
      if LessFunc(A[i], A[i-1]) then
        SwapProc(A, i-1, i);
    inc(Left);
    for i := succ(Left) to Right do
      if LessFunc(A[i], A[i-1]) then
        SwapProc(A, i-1, i);
    dec(Right);
  end;
end;


procedure VisualSelectionSort(var A           : array of integer;
                                  Left, Right : integer;
                                  LessFunc    : TLessFunction;
                                  SwapProc    : TSwapFunction);
var
  i, j : integer;
  IndexOfMin : integer;
begin
  for i := Left to pred(Right) do begin
    IndexOfMin := i;
    for j := succ(i) to Right do
      if LessFunc(A[j], A[IndexOfMin]) then
        IndexOfMin := j;
    SwapProc(A, i, IndexOfMin);
  end;
end;

procedure VisualInsertionSort(var A           : array of integer;
                                  Left, Right : integer;
                                  LessFunc    : TLessFunction;
                                  SetProc     : TSetFunction);
var
  i, j : integer;
  Temp : TSortElement;
begin
  for i := succ(Left) to Right do begin
    Temp := A[i];
    j := i;
    while (j > Left) and LessFunc(Temp, A[j-1]) do begin
      SetProc(A, A[j-1], j);
      dec(j);
    end;
    SetProc(A, Temp, j);
  end;
end;

procedure VisualBestInsertionSort(var A           : array of integer;
                                      Left, Right : integer;
                                      LessFunc    : TLessFunction;
                                      SwapProc    : TSwapFunction;
                                      SetProc     : TSetFunction);
var
  i, j : integer;
  IndexOfMin : integer;
  Temp : TSortElement;
begin
  {find the smallest element and put it in the first position}
  IndexOfMin := Left;
  for i := succ(Left) to Right do
    if LessFunc(A[i], A[IndexOfMin]) then
      IndexOfMin := i;
  if (Left <> IndexOfMin) then
    SwapProc(A, Left, IndexOfMin);
  {now sort via insertion method}
  for i := Left+2 to Right do begin
    Temp := A[i];
    j := i;
    while LessFunc(Temp, A[j-1]) do begin
      SetProc(A, A[j-1], j);
      dec(j);
    end;
    SetProc(A, Temp, j);
  end;
end;

procedure VisualShellsort(var A           : array of integer;
                              Left, Right : integer;
                              LessFunc    : TLessFunction;
                              SwapProc    : TSwapFunction;
                              SetProc     : TSetFunction);
var
  i, j : integer;
  h    : integer;
  Temp : TSortElement;
begin
  {firstly calculate the first h value we shall use: it'll be about
   one ninth of the number of the elements}
  h := 1;
  while (h <= (Right - Left) div 9) do
    h := (h * 3) + 1;
  {start a loop that'll decrement h by one third each time through}
  while (h > 0) do begin
    {now insertion sort each h-subfile}
    for i := (Left + h) to Right do begin
      Temp := A[i];
      j := i;
      while (j >= (Left + h)) and LessFunc(Temp, A[j-h]) do begin
        SetProc(A, A[j-h], j);
        dec(j, h);
      end;
      SetProc(A, Temp, j);
    end;
    {decrease h by a third}
    h := h div 3;
  end;
end;

procedure VisualQuicksort(var A           : array of integer;
                              Left, Right : integer;
                              LessFunc    : TLessFunction;
                              SwapProc    : TSwapFunction);
  function Partition(L, R : integer) : integer;
  var
    i, j : integer;
    Temp : TSortElement;
  begin
    {set up the indexes}
    i := L;
    j := pred(R);
    {get the partition element}
    Temp := A[R];
    {do forever (we'll break out of the loop when needed)}
    while true do begin
      {find the first element greater than or equal to the partition
       element from the left; note that our partition element will
       stop this loop}
      while LessFunc(A[i], Temp) do
        inc(i);
      {find the first element less than the partition element from the
       right; check to break out of the loop if we hit the left
       element - we have no sentinel there}
      while LessFunc(Temp, A[j]) do begin
        if (j = L) then
          Break;
        dec(j);
      end;
      {if we crossed get out of this infinite loop to swap the
       partition element into place}
      if (i >= j) then
        Break;
      {otherwise swap the two out-of-place elements}
      SwapProc(A, i, j);
      {and continue}
      inc(i);
      dec(j);
    end;
    {swap the partition element into place, return the dividing index}
    SwapProc(A, i, R);
    Result := i;
  end;
  procedure QuickSortPrim(L, R : integer);
  var
    DividingItem : integer;
  begin
    {stop the recursion, if needed}
    if (R - L) <= 0 then
      Exit;
    {otherwise, partition about the final element in the set}
    DividingItem := Partition(L, R);
    {recursively quicksort the two subsets either side of the dividing
     element}
    QuickSortPrim(L, pred(DividingItem));
    QuickSortPrim(succ(DividingItem), R);
  end;
begin
  {start it all off}
  QuickSortPrim(Left, Right);
end;

procedure VisualBestQuicksort(var A           : array of integer;
                                  Left, Right : integer;
                                  LessFunc    : TLessFunction;
                                  SwapProc    : TSwapFunction;
                                  SetProc     : TSetFunction);
  function Partition(L, R : integer) : integer;
  var
    i, j : integer;
    Temp : TSortElement;
  begin
    {set up the indexes}
    i := L;
    j := pred(R);
    {get the partition element}
    Temp := A[R];
    {do forever (we'll break out of the loop when needed)}
    while true do begin
      {find the first element greater than or equal to the partition
       element from the left; note that our partition element will
       stop this loop}
      while LessFunc(A[i], Temp) do
        inc(i);
      {find the first element less than the partition element from the
       right; note the median-of-three algorithm has ensured we have
       a sentinel on the left}
      while not LessFunc(A[j], Temp) do
        dec(j);
      {if we crossed get out of this infinite loop to swap the
       partition element into place}
      if (i >= j) then
        Break;
      {otherwise swap the two out-of-place elements}
      SwapProc(A, i, j);
      {and continue}
      inc(i);
      dec(j);
    end;
    {swap the partition element into place, return the dividing index}
    SwapProc(A, i, R);
    Result := i;
  end;
  procedure QuickSortPrim(L, R : integer);
  var
    DividingItem : integer;
    Temp : TSortElement;
    i, j : integer;
  begin
    {if needed, stop the recursion at the cut-off point, and insertion
     sort}
    if (R - L) <= 10 then begin
      for i := succ(L) to R do begin
        Temp := A[i];
        j := i;
        while (j > L) and LessFunc(Temp, A[j-1]) do begin
          SetProc(A, A[j-1], j);
          dec(j);
        end;
        SetProc(A, Temp, j);
      end;
      Exit;
    end;
    {calculate the median-of-three element; for an extra bit of speed,
     put the smallest element of the three in the first position, the
     greatest in the last position, and the median in the last-but-one
     position and partition a smaller subset excluding the first and
     last}
    SwapProc(A, (L+R) shr 1, pred(R));
    if not LessFunc(A[L], A[pred(R)]) then
      SwapProc(A, L, pred(R));
    if not LessFunc(A[L], A[R]) then
      SwapProc(A, L, R);
    if not LessFunc(A[pred(R)], A[R]) then
      SwapProc(A, pred(R), R);
    DividingItem := Partition(succ(L), pred(R));
    {recursively quicksort the two subsets either side of the dividing
     element}
    QuickSortPrim(L, pred(DividingItem));
    QuickSortPrim(succ(DividingItem), R);
  end;
begin
  {start it all off}
  QuickSortPrim(Left, Right);
end;

end.